home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gwuada_9.zip / SMISC.C < prev    next >
C/C++ Source or Header  |  1993-12-20  |  43KB  |  1,423 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #include "hdr.h"
  11. #include "vars.h"
  12. #include "setp.h"
  13. #include "dbxp.h"
  14. #include "arithp.h"
  15. #include "chapp.h"
  16. #include "dclmapp.h"
  17. #include "miscp.h"
  18. #include "smiscp.h"
  19.  
  20. /* smisc.c: miscellaneous sem procedures needing semhdr.h */
  21. /* 
  22.  * 23-sep-85    ds
  23.  * add ast_clear to clear defined ast fields before resetting N_KIND.
  24.  *
  25.  * 11-jul-86    ACD
  26.  * modified the DEFINED fields for length clauses.  Previously only
  27.  * N_AST1 was recognized as being defined.  Now, both N_AST1 (the 
  28.  * attribute node) and N_AST2 ( the expression) are recognized
  29.  *
  30.  * 16-apr-85    ds
  31.  * add procedures fordeclared_1 and fordeclared_2. These are used to
  32.  * initialize and advance iteration over declared maps, and are 
  33.  * introduced to reduce the size of the FORDECLARED macro.
  34.  *
  35.  * 24-dec-84    ds
  36.  * have dcl_put NOT set visibility by default.
  37.  *
  38.  * 07-nov-84    ds
  39.  * have node_new_noseq set spans info.
  40.  * add spans_copy(new, old) to copy spans information from node old
  41.  * to node new.
  42.  *
  43.  * 04-nov-84    ds
  44.  * move undone() here as undone.c no longer needed.
  45.  *
  46.  * 02-nov-84    ds
  47.  * add attribute_str to return attribute name based on attribute
  48.  * code in N_VAL field of attribute node.
  49.  *
  50.  * 22-oct-84    ds
  51.  * add dcl_put_vis to enter with explicit visibility indication.
  52.  *
  53.  * 12-oct-84    ds
  54.  * merge in procedures formerly in dcl.c
  55.  */
  56.  
  57. static int const_cmp_kind(Const, Const);
  58.  
  59. void ast_clear(Node node)                                    /*;ast_clear*/
  60. {
  61.     int nk = N_KIND(node);
  62.     if (N_AST2_DEFINED(nk)) N_AST2(node) = (Node) 0;
  63.     if (N_AST3_DEFINED(nk)) N_AST3(node) = (Node) 0;
  64.     if (N_AST4_DEFINED(nk)) N_AST4(node) = (Node) 0;
  65. }
  66.  
  67. Const const_new(int k)                                        /*;const_new*/
  68. {
  69.     Const    result;
  70.  
  71.     result = (Const) smalloc(sizeof(Const_s));
  72.     result->const_kind = k;
  73.     result->const_value.const_int = 0; /* reasonable default value */
  74.     return result;
  75. }
  76.  
  77. Const int_const(int x)                                    /*;int_const*/
  78. {
  79.     Const    result;
  80.  
  81.     result = const_new(CONST_INT);
  82.     result->const_value.const_int = x;
  83.     return result;
  84. }
  85.  
  86. Const fixed_const(long x)                                /*;fixed_const*/
  87. {
  88.     Const    result;
  89.     result = const_new(CONST_FIXED);
  90.     result->const_value.const_fixed = x;
  91.     return result;
  92. }
  93.  
  94. Const uint_const(int *x)                                /*;uint_const*/
  95. {
  96.     Const    result;
  97.  
  98.     if (x == (int *)0) result = const_new(CONST_OM);
  99.     else {
  100.         result = const_new(CONST_UINT);
  101.         result->const_value.const_uint = x;
  102.     }
  103.     return result;
  104. }
  105.  
  106. Const real_const(double x)                                /*;real_const*/
  107. {
  108.     Const    result;
  109.  
  110.     result = const_new(CONST_REAL);
  111.     result->const_value.const_real = x;
  112.     return result;
  113. }
  114.  
  115. Const rat_const(Rational x)                                /*;rat_const*/
  116. {
  117.     Const    result;
  118.  
  119.     if (x == (Rational)0) result =  const_new(CONST_OM);
  120.     else {
  121.         result = const_new(CONST_RAT);
  122.         result->const_value.const_rat = x;
  123.     }
  124.     return result;
  125. }
  126.  
  127. /* Comparison functions for ivalues (Const's) */
  128.  
  129. int const_eq(Const const1, Const const2)                /*;const_eq*/
  130. {
  131.     /* checks to see if 2 Consts have the same value */
  132.  
  133.     switch (const_cmp_kind(const1, const2)) {
  134.     case CONST_OM:
  135.     case CONST_CONSTRAINT_ERROR:
  136.         return TRUE;
  137.     case CONST_INT:
  138.         return (INTV(const1) == INTV(const2));
  139.     case CONST_FIXED:
  140.         return (FIXEDV(const1) == FIXEDV(const2));
  141.     case CONST_UINT:
  142.         return int_eql(UINTV(const1), UINTV(const2));
  143.     case CONST_REAL:
  144.         return (RATV(const1) == RATV(const2));
  145.     case CONST_RAT:
  146.         return rat_eql(RATV(const1), RATV(const2));
  147.     case CONST_STR:
  148.         return streq(const1->const_value.const_str,
  149.           const2->const_value.const_str);
  150.     default:
  151.         return const_cmp_undef(const1, const2);
  152.     }
  153. }
  154.  
  155. int const_ne(Const cleft, Const cright)                        /*;const_ne*/
  156. {
  157.     return !const_eq(cleft, cright);
  158. }
  159.  
  160. int const_lt(Const cleft, Const cright)                        /*;const_lt*/
  161. {
  162.     switch (const_cmp_kind(cleft, cright)) {
  163.     case CONST_INT :
  164.         return (INTV(cleft)<INTV(cright));
  165.     case CONST_UINT :
  166.         return int_lss(UINTV(cleft), UINTV(cright));
  167.     case CONST_FIXED :
  168.         return (FIXEDV(cleft)<FIXEDV(cright));
  169.     case CONST_RAT :
  170.         return rat_lss(RATV(cleft), RATV(cright));
  171.     case CONST_REAL :
  172.         return  REALV(cleft) < REALV(cright);
  173.     default :
  174.         const_cmp_undef(cleft, cright);
  175.         return 0;
  176.     }
  177. }
  178.  
  179. int const_le(Const cleft, Const cright)                        /*;const_le*/
  180. {
  181.     return (const_eq(cleft, cright) || const_lt(cleft, cright));
  182. }
  183.  
  184. int const_gt(Const cleft, Const cright)                        /*;const_gt*/
  185. {
  186.     return const_lt(cright, cleft);
  187. }
  188.  
  189. int const_ge(Const cleft, Const cright)                        /*;const_ge*/
  190. {
  191.     return const_eq(cleft, cright) || const_lt(cright, cleft);
  192. }
  193.  
  194. static int const_cmp_kind(Const cleft, Const cright)        /*;const_cmp_kind*/
  195. {
  196.     int        ckind;
  197.  
  198.     ckind = cleft->const_kind;
  199.     if (ckind == CONST_OM) chaos("const comparison left operand not defined");
  200.     if (ckind != cright->const_kind) {
  201. #ifdef DEBUG
  202.         zpcon(cleft); 
  203.         zpcon(cright);
  204. #endif
  205.         chaos("const comparison operands differing kinds");
  206.     }
  207.     return ckind;
  208. }
  209.  
  210. int const_same_kind(Const cleft, Const cright)            /*;const_same_kind*/
  211. {
  212.     /* returns boolean value indicating whether two Consts are of same kind */
  213.     return (cleft->const_kind == cright->const_kind);
  214. }
  215.  
  216. int const_cmp_undef(Const cleft, Const cright)        /*;const_cmp_undef*/
  217. {
  218. #ifdef DEBUG
  219.     zpcon(cleft); 
  220.     zpcon(cright);
  221. #endif
  222.     chaos("const comparison not defined for these constant types");
  223.     return 0; /* for sake of lint */
  224. }
  225.  
  226. int fx_mantissa(Rational lbd, Rational ubd, Rational small)        /*;mantissa*/
  227. {
  228.     Rational exact_val;
  229.     int *vnum, *vden, *int_1;
  230.     int     power;
  231.  
  232.     lbd = rat_abs(lbd);
  233.     ubd = rat_abs(ubd);
  234.  
  235.     /*  find the exact # of values to be represented (aside from 0) */
  236.  
  237.     if (rat_gtr(lbd, ubd))
  238.         exact_val = rat_div(lbd, small);
  239.     else
  240.         exact_val = rat_div(ubd, small);
  241.     vnum = num(exact_val);
  242.     vden = den(exact_val);
  243.     int_1 = int_fri(1);
  244.  
  245.     /* the mantissa is calculated assuming that the bound is 'small away
  246.      * from a model number, so we subtract one before computing no. of bits
  247.      */
  248.  
  249.     vnum = int_sub(vnum, int_1);
  250.     vnum = int_quo(vnum, vden);
  251.     vden = int_fri(1);
  252.     power = 1;
  253.     while (int_gtr(vnum, vden)) {
  254.         power++;
  255.         vden = int_add(int_add(vden, vden), int_1);
  256.     }
  257.     return power;
  258. }
  259.  
  260. /* Not used */
  261. void node_free(Node node)                                    /*;node_free*/
  262. {
  263.     /* free nodeentry. Since state of allocated fields not clear
  264.      * only free the node block itself
  265.      */
  266.     chaos("node free");
  267.     if (node != (Node)0) efreet((char *) node, "node-free");
  268. }
  269.  
  270. void to_errfile(char *txt)                                    /*;to_errfile */
  271. {
  272.     printf("%s\n", txt);
  273. }
  274.  
  275. int needs_body(Symbol name)  /*;needs_body*/    
  276. {
  277.     /* Procedures and function specs need bodies of course. So do package
  278.      * specs that contain objects which need bodies.
  279.      */
  280.  
  281.     Symbol    obj;
  282.     char    *id;
  283.     Fordeclared    fd1;
  284.     int    nat;
  285.  
  286.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  needs_body");
  287.  
  288.     nat = NATURE(name);
  289.     if (nat == na_package_spec || nat == na_generic_package_spec) {
  290.         FORDECLARED(id, obj, DECLARED(name), fd1);
  291.             if (IS_VISIBLE(fd1) && obj->scope_of == name
  292.               && needs_body(obj)) return TRUE;
  293.         ENDFORDECLARED(fd1);
  294.         FORDECLARED(id, obj, DECLARED(name), fd1)
  295.             if (TYPE_OF(obj) == symbol_incomplete) return TRUE;
  296.         ENDFORDECLARED(fd1);
  297.         return FALSE;
  298.     }
  299.     if (nat == na_procedure_spec || nat == na_function_spec 
  300.       || nat == na_task_type_spec || nat == na_task_obj_spec
  301.       || nat == na_generic_procedure_spec || nat == na_generic_function_spec)
  302.         return TRUE;
  303.     return FALSE;
  304. }
  305.  
  306. /* The text of kind_str that follows is generated by a spitbol program
  307.  * called AS
  308.  */
  309. char *kind_str(unsigned int as)        /*;kind_str*/
  310. {
  311.     static char *as_names[] = {
  312.         "pragma",
  313.         "arg",
  314.         "obj_decl",
  315.         "const_decl",
  316.         "num_decl",
  317.         "type_decl",
  318.         "subtype_decl",
  319.         "subtype_indic",
  320.         "derived_type",
  321.         "range",
  322.         "range_attribute",
  323.         "constraint",
  324.         "enum",
  325.         "int_type",
  326.         "float_type",
  327.         "fixed_type",
  328.         "digits",
  329.         "delta",
  330.         "array_type",
  331.         "box",
  332.         "subtype",
  333.         "record",